perm filename EXPR.SAI[PNT,HE]14 blob
sn#414244 filedate 1979-02-01 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00007 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 IFCR NOT DECLARATION($$PRGID) THENC
C00004 00003 ! compute_func,uncompute_func,error,ggtoken
C00007 00004 ! MAKE_CODE, EVAL_CODE
C00020 00005 ! procedures exp,term,factor
C00030 00006 ! function evaluation routines: EVAL, REDUCE
C00034 00007 ! GTEXPR, FNEXPR
C00036 ENDMK
C⊗;
IFCR NOT DECLARATION($$PRGID) THENC
entry;
BEGIN "EXPR" ENDC
DEFINE $EXPR=TRUE ;
REQUIRE "HEADER.SAI" SOURCE_FILE;
PRESET_WITH NULL,"SCALAR","VECTOR","ROT","TRANS","FRAME","MACRO","FUNCTION";
INTERNAL STRING ARRAY $DTYPE[0:7];
define token_class = [tokenclass],token_index=[tokenindex];
INTERNAL RPTR (EXPR) PROCEDURE MK_EXPR(RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME,EXPR,FUNCTION,SYMBOL) PTR;
INTEGER TYPE; RPTR(EXPR) EX(NULL_RECORD));
α RPTR(EXPR)X; X←NEW_RECORD(EXPR);
EXPR:PTR[X]←PTR; EXPR:TYPE[X]←TYPE;
EXPR:NEXT[X]←EX;
RETURN(X);
β;
INTERNAL RPTR(TREE)PROCEDURE NWTREE(RPTR(SCALAR, VECTOR,ROT,TRANS,FRAME,SYMBOL) R; INTEGER T);
α RPTR(TREE) K; K←NEW_RECORD(TREE);
TREE:DATA[K]←R; TREE:DTYPE[K]←T; RETURN(K); β;
EXTERNAL RPTR(FRAME) F_BARM,F_YARM,F_POINTER,F_ARM,F_WRLD;
RPTR(FRAME) PROCEDURE JOINEDTOARM(RPTR(FRAME) OBJ);
BEGIN
RPTR(FRAME) TEMP;
IF OBJ=F_BARM OR OBJ=F_YARM
THEN RETURN(OBJ);
IF OBJ=F_POINTER
THEN RETURN(F_ARM);
TEMP←FRAME:DAD[OBJ];
WHILE TEMP≠F_WRLD
DO BEGIN
IF TEMP=F_YARM OR TEMP=F_BARM
THEN RETURN(TEMP);
IF TEMP=NULL_RECORD THEN RETURN(TEMP);
TEMP←FRAME:DAD[TEMP];
END;
RETURN(NULL_RECORD);
END;
! compute_func,uncompute_func,error,ggtoken;
STRING EXPRESSION_STRING;
RPTR(EXPR) SYMSTACKTOP;
rptr(function) fn_cur;
RPTR(EXPR)PROCEDURE PUSHSYMSTACK(RPTR(SYMBOL) S;INTEGER N);
BEGIN
RPTR(EXPR)SY;
SY←SYMSTACKTOP;
WHILE SY≠NULL_RECORD AND EXPR:PTR[SY]≠S DO SY←EXPR:NEXT[SY];
IF SY=NULL_RECORD THEN
BEGIN SY←MK_EXPR(S,N,SYMSTACKTOP);
SYMSTACKTOP←SY;
END;
RETURN(SY);
END;
INTEGER PROCEDURE COMPUTE_FUNC(INTEGER I1,I2,I3(0),I4(0),I5(0));
RETURN(((((I1*#DTYPE +I2)*#DTYPE + I3)*#DTYPE) + I4)*#DTYPE +I5);
DEFINE MCOMPUTE_FUNC(I1,I2,I3,I4,I5) =
[(((((I1*#DTYPE +I2)*#DTYPE + I3)*#DTYPE) + I4)*#DTYPE +I5)];
INTEGER PROCEDURE UNCOMPUTE_FUNC(INTEGER I1,I2);
α INTEGER I;
CASE I2 OF
α [1] I←I1 DIV #DTYPE↑4;
[2] I←(I1 DIV #DTYPE↑3)MOD #DTYPE;
[3] I←(I1 DIV #DTYPE↑2) MOD #DTYPE;
[4] I←(I1 DIV #DTYPE) MOD #DTYPE;
[5] I←I1 MOD #DTYPE;
ELSE ERROR("WRONG FIELD IN UNCOMPPUTE_FUNC PARSER ERROR")
β;
RETURN(I);
β;
define token_ptr=[tokenptr];
PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α IF STOKEN THEN GTOKEN(FLAG)
ELSE BEGIN GTOKEN(FLAG);
EXPRESSION_STRING←EXPRESSION_STRING&" "&TOKEN; END;
IF #TOKEN=INT_TYPE OR #TOKEN=REAL_TYPE THEN
α INTEGER I;
TOKENINDEX←#SC;
TOKEN_PTR←SMAKE(REALSCAN(TOKEN,I));
β
ELSE IF #TOKEN=OPERATOR_TYPE THEN DECSTR(TOKEN);
β;
PROCEDURE ECOPY(RPTR(EXPR)R1,R2);
α EXPR:PTR[R1]←EXPR:PTR[R2];
EXPR:TYPE[R1]←EXPR:TYPE[R2];
EXPR:NEXT[R1]←EXPR:NEXT[R2];
β;
! MAKE_CODE, EVAL_CODE;
REQUIRE "⊂⊃⊂⊃" REPLACE_DELIMITERS;
! returns the index of the array A whose element has value val, 0 if
no such element ;
INTEGER PROCEDURE MATINX(INTEGER VAL; INTEGER ARRAY A; INTEGER LB,UB);
α INTEGER L,M,U;
L←LB; U←UB;
DO α M←(U+L)/2;
IF A[M]=VAL THEN RETURN(M)
ELSE IF A[M]>VAL THEN U←M-1
ELSE L←M+1;
β UNTIL L>U;
RETURN(0);
β;
DEFINE OPCODE = ⊂
! xx( operator, operator code, arg1 type, arg2 type, result type, routine to call) ;
XX("*", TIMES_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"*")⊃)
XX("*", TIMES_X, #SC, #VT, #VT, ⊂OPSCVT(#1,#2,"*")⊃)
XX("*", TIMES_X, #VT, #SC, #VT, ⊂OPSCVT(#2,#1,"*")⊃)
XX("*", TIMES_X, #VT, #VT, #VT, ⊂OPVET(#1,#2,"*")⊃)
XX("*", TIMES_X, #RT, #VT, #VT, ⊂OPRTVT(#1,#2)⊃)
XX("*", TIMES_X, #RT, #RT, #RT, ⊂OPRTRT(#1,#2)⊃)
XX("*", TIMES_X, #TR, #VT, #VT, ⊂OPTRVT(#1,#2)⊃)
XX("*", TIMES_X, #TR, #TR, #TR, ⊂OPTRTR(#1,#2)⊃)
XX("*", TIMES_X, #TR, #FR, #FR, ⊂OPTRFR(#1,#2)⊃)
XX("*", TIMES_X, #FR, #TR, #FR, ⊂OPFRTR(#1,#2)⊃)
XX("*", TIMES_X, #FR, #FR, #FR, ⊂OPFR(#1,#2)⊃)
XX(".", DOT_X, #VT, #VT, #SC, ⊂OPDOT(#1,#2)⊃)
XX("REL", REL_X, #VT, #FR, #VT, ⊂OPVTFR(#2,#1)⊃)
XX("→", BACKARROW_X, #FR, #FR, #TR, ⊂OPFRFR(#1,#2)⊃)
XX("/", DIVIDE_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"/")⊃)
XX("/", DIVIDE_X, #VT, #SC, #VT, ⊂OPSCVT(#2,#1,"/")⊃)
XX("MIN",MIN_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"MIN")⊃)
XX("MAX",MAX_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"MAX")⊃)
XX("MOD",MOD_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"MOD")⊃)
XX("DIV",DIV_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"DIV")⊃)
XX("+", PLUS_X, #SC, 0, #SC, ⊂OPSCAL(#1,0.,"+")⊃)
XX("+", PLUS_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"+")⊃)
XX("+", PLUS_X, #VT, 0, #VT, ⊂OPVET(#1,NEW_RECORD(VECTOR),"+")⊃)
XX("+", PLUS_X, #VT, #VT, #VT, ⊂OPVET(#1,#2,"+")⊃)
XX("+", PLUS_X, #VT, #FR, #FR, ⊂OPFRVT(#1,#2,"+")⊃)
XX("+", PLUS_X, #FR, #VT, #FR, ⊂OPFRVT(#2,#1,"+")⊃)
XX("-", MINUS_X, #SC, 0, #SC, ⊂OPSCAL(0.,#1,"-")⊃)
XX("-", MINUS_X, #SC, #SC, #SC, ⊂OPSCAL(#1,#2,"-")⊃)
XX("-", MINUS_X, #VT, 0, #VT, ⊂OPVET(NEW_RECORD(VECTOR),#1,"-")⊃)
XX("-", MINUS_X, #VT, #VT, #VT, ⊂OPVET(#1,#2,"-")⊃)
XX("-", MINUS_X, #FR, #VT, #FR, ⊂OPFRVT(#2,#1,"-")⊃)
! XX("WRT", WRT_X, ) ;
! yy(operator, operator code, fn to call, result type, #of args, arg types) ;
YY("POS", POS_X, TPOS, #VT, 1, #TR, 0, 0)
YY("POS", POS_X, FPOS, #VT, 1, #FR, 0, 0)
YY("UNIT", UNIT_X, NORMVT, #VT, 1, #VT, 0, 0)
! YY("AXIS", AXIS_X, FAXIS, #VT, 1, #RT, 0, 0) ;
! YY("ORIENT", ORIENT_X, FORIENT,#RT, 1, #TR, 0, 0) ;
! YY("REL", REL_X, RELVT, #VT, 2, #VT, #FR, 0) ;
! YY("REL", REL_X, RELFR, #FR, 2, #FR, #TR, 0) ;
! YY("WRT", WRT_X, WRTVT, #VT, 2, #VT, #FR, 0) ;
YY("ORIENT", ORIENT_X, FORIEN, #RT, 1, #FR, 0, 0)
YY("CONSTRUCT", CONSTRUCT_X, CONSV, #FR, 3, #VT, #VT, #VT)
YY("CONSTRUCT", CONSTRUCT_X, CONSF, #FR, 3, #FR, #FR, #FR)
YY("FRAME", FRAME_X, FMAKE, #FR, 2, #RT, #VT, 0)
YY("VECTOR", VECTOR_X, VMAKE, #VT, 3, #SC, #SC, #SC)
YY("TRANS", TRANS_X, TMAKE, #TR, 2, #RT, #VT, 0)
YY("MAGNITUDE", MAGNITUDE_X, SMOD, #SC, 1, #SC, 0, 0)
YY("MAGNITUDE", MAGNITUDE_X, VMOD, #SC, 1, #VT, 0, 0)
! YY("MAGNITUDE", MAGNITUDE_X, RMOD, #SC, 1, #RT, 0, 0) ;
YY("IMPLICIT", IMPLICIT_X, VMAKE, #VT, 3, #SC, #SC, #SC)
YY("IMPLICIT", IMPLICIT_X, RMAKE, #RT, 2, #VT, #SC, 0)
YY("IMPLICIT", IMPLICIT_X, TMAKE, #TR, 2, #RT, #VT, 0)
YY("↑", UPARROW_X, ORIENU, #FR, 1, #FR, 0, 0)
YY("↓", DOWNARROW_X, ORIEND, #FR, 1, #FR, 0, 0)
YY("$", DOLLAR_X, ORIEN$, #FR, 1, #FR, 0, 0)
YY("α", ALPHA_X, ORIENα, #FR, 1, #FR, 0, 0)
YY("SQRT", SQRT_X, FSQRT, #SC, 1, #SC, 0, 0)
YY("INT", INT_X, FINT, #SC, 1, #SC, 0, 0)
YY("SIN", SINE_X, FSIN, #SC, 1, #SC, 0, 0)
YY("COS", COSINE_X, FCOS, #SC, 1, #SC, 0, 0)
YY("ASIN", ASINE_X, FASIN, #SC, 1, #SC, 0, 0)
YY("ACOS", ACOSINE_X, FACOS, #SC, 1, #SC, 0, 0)
YY("ATAN2", ATAN2_X, FATAN2, #SC, 2, #SC, #SC, 0)
YY("LOG", LOG_X, FLOG, #SC, 1, #SC, 0, 0)
YY("EXP", EXP_X, FEXP, #SC, 1, #SC, 0, 0)
YY("ROT", ROT_X, RMAKE, #RT, 2, #VT, #SC, 0)
YY("ROT", ROT_X, VRMAKE, #RT, 3, #VT, #VT, #VT)
⊃;
! counts number of different allowable combinations of operators,
arguments, and types of arguments, and for each
computes an integer function ;
REDEFINE XXCOUNT=0;
redefine XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) = ⊂
REDEFINE XXCOUNT=XXCOUNT+1;
REDEFINE XX_VAL=((op_type*#dtype + type1)* #dtype + type2)*#DTYPE*#DTYPE;
XX_VAL ,⊃;
redefine YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#N,#1,#2,#3) = ⊂
REDEFINE XXCOUNT=XXCOUNT+1;
REDEFINE XX_VAL=MCOMPUTE_FUNC(op_type,#1,#2,#3,0);
REDEFINE XX_TEMP=⊂XX_VAL ,⊃;
XX_TEMP ⊃;
! array OCODE consists of all the codes defined;
preset_array(OCODE, OPCODE, INTEGER, 1, XXCOUNT);
DEFINE FUNCTION_X=XXCOUNT + 1;
redefine XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) = ⊂
TYPE3 , ⊃ ;
redefine YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#N,#1,#2,#3) = ⊂
OP_DTYPE, ⊃;
preset_array(OPTYPE, OPCODE, INTEGER, 1, XXCOUNT);
! this procedure calls the relevant expression evaluation routine;
RPTR(EXPR) PROCEDURE MAKE_CODE(INTEGER $$$$, NARG; RPTR(EXPR)R1);
α RPTR(EXPR)R3; INTEGER PP,I; INTEGER ARRAY Q[1:4];
R3←R1;
IF $$$$=FUNCTION_X THEN
α RPTR(FUNCTION,SCALAR,VECTOR,ROT,FRAME,TRANS,EXPR)F;
F←EXPR:PTR[R1];
IF NARG≠(pp←FUNCTION:NARGS[F])
THEN ERROR("function is supposed to have "&cvs(pp)&" arguments, but only has "&cvs(narg)&" arguments");
IF NARG>0 THEN
BEGIN
R3←EXPR:NEXT[R1];
FOR I←1 STEP 1 UNTIL NARG DO
BEGIN RPTR(EXPR)R4;
PP←EXPR:TYPE[R4←R3];
IF PP>#DTYPE THEN PP←PP MOD #DTYPE;
WHILE PP=#EX DO
BEGIN R4←EXPR:PTR[R4];
PP←EXPR:TYPE[R4];
IF PP>#DTYPE THEN PP←PP MOD #DTYPE;
END;
IF PP≠FUNCTION:ARGTYPE[F][I] THEN
ERROR("Argument "&cvs(I)&" should be type "&
$DTYPE[FUNCTION:ARGTYPE[F][I]]&
", not "&$DTYPE[PP]);
R3←EXPR:NEXT[R3];
END;
END;
R3←MK_EXPR(R1,COMPUTE_FUNC(FUNCTION_X,0,0,0,FUNCTION:TYPE[F]));
β
ELSE
BEGIN
! expand the arguments from a linked list into an array ;
FOR I←1 STEP 1 UNTIL NARG MIN 4 DO
BEGIN RPTR(EXPR)R4;
Q[I]←EXPR:TYPE[R4←R3];
IF Q[I]>#DTYPE THEN Q[I]←Q[I] MOD #DTYPE;
WHILE Q[I]=#EX
DO BEGIN R4←EXPR:PTR[R4];
Q[I]←EXPR:TYPE[R4];
IF Q[I]>#DTYPE THEN Q[I]←Q[I] MOD #DTYPE;
END;
IF Q[I]=#SY THEN Q[I]←EXPR:TYPE[EXPR:PTR[R4]];
R3←EXPR:NEXT[R3]; END;
PP←COMPUTE_FUNC($$$$,Q[1],Q[2],Q[3],Q[4]);
I←MATINX(PP,OCODE,1,XXCOUNT);
IF I=0
THEN ERROR(CODE_OP[$$$$]&" cannot take argument(s) type(s) "&
$DTYPE[Q[1]]&" "&$DTYPE[Q[2]]&" "&$DTYPE[Q[3]]&" "&$DTYPE[Q[4]])
ELSE R3←MK_EXPR(R1, COMPUTE_FUNC($$$$,NARG,0,0,OPTYPE[I]));
END;
return(R3);
β;
RPTR(EXPR) PROCEDURE EVAL_CODE(INTEGER $$$$, NARG; RPTR(EXPR)R1);
α RPTR(EXPR)R3; INTEGER PP,I; INTEGER ARRAY Q[1:4];
REAL ARRAY QQ[1:4];
rptr(scalar,vector,trans,rot,frame) ARRAY rr[1:4];
REDEFINE YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#n,#1,#2,#3) = ⊂
redefine rr1= ⊂ ifc #1=#sc thenc QQ[1] elsec RR[1] ENDC ⊃;
redefine rr2= ⊂ ifc #2=#sc thenc QQ[2] elsec RR[2] ENDC ⊃;
redefine rr3= ⊂ ifc #3=#sc thenc QQ[3] elsec RR[3] ENDC ⊃;
redefine xx_temp = ⊂
CASEC #n OFC
⊂;R3←MK_EPXR(OP_FUNC,OP_DTYPE,NULL_RECORD)⊃,
⊂;R3←MK_EXPR(OP_FUNC(rr1),OP_DTYPE)⊃,
⊂;R3←MK_EXPR(OP_FUNC(rr1,rr2),OP_DTYPE)⊃,
⊂;R3←MK_EXPR(OP_FUNC(rr1,rr2,rr3),OP_DTYPE)⊃,
⊂;REQUIRE " HAH" MESSAGE;⊃ ENDC
⊃;
xx_temp ⊃;
REDEFINE XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) =
⊂ redefine #1 = ⊂ IFC TYPE1=#SC THENC QQ[1] ELSEC rr[1] ENDC ⊃ ;
redefine #2 = ⊂ IFC TYPE2=#SC THENC QQ[2] ELSEC rr[2] ENDC ⊃ ;
redefine xx_temp = ⊂
IFC (#SC≤TYPE3≤#FR) THENC
; R3←MK_EXPR(FUNC,TYPE3)
ELSEC ; REQUIRE " HAH " MESSAGE; ENDC ⊃;
xx_temp ⊃;
R3←R1;
! expand the arguments from a linked list into an array ;
FOR I←1 STEP 1 UNTIL NARG MIN 4 DO
BEGIN
RR[I]←EXPR:PTR[R3];
IF (Q[I]←EXPR:TYPE[R3])=#SC
THEN QQ[I]←SCALAR:VALUE[RR[I]]
ELSE IF Q[I]>#DTYPE THEN Q[I]←Q[I] MOD #DTYPE;
R3←EXPR:NEXT[R3]; END;
PP←COMPUTE_FUNC($$$$,Q[1],Q[2],Q[3],Q[4]);
I←MATINX(PP,OCODE,1,XXCOUNT);
CASE I OF
BEGIN
ERROR(CODE_OP[$$$$]&" cannot take argument(s) type(s) "&
$DTYPE[Q[1]]&" "&$DTYPE[Q[2]]&" "&$DTYPE[Q[3]]&" "&$DTYPE[Q[4]])
OPCODE
END;
return(R3);
β;
! procedures exp,term,factor;
! E: {+|-} T {+|- T }
T: F {*|/ F}
F: ( E ),
f( , , ...)
<constant>,
<id>, ;
! EXP E: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> ;
FORWARD RECURSIVE RPTR(EXPR)PROCEDURE TERM;
FORWARD RECURSIVE RPTR(EXPR)PROCEDURE FACTOR;
! EXP E: {+|-} T {+|- T } ;
RECURSIVE RPTR(EXPR) PROCEDURE EXP;
α RPTR(EXPR) $$1; INTEGER I;
IF #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #EXP THEN
α I←TOKEN_INDEX;
GGTOKEN; $$1←TERM;
$$1←MAKE_CODE(I,1,$$1);
β
ELSE $$1←TERM;
WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #EXP DO
α I←TOKEN_INDEX;
GGTOKEN; EXPR:NEXT[$$1]←TERM;
$$1←MAKE_CODE(I,2,$$1);
β;
RETURN($$1);
β;
! TERM T: F {*|/ F} ;
RECURSIVE RPTR(EXPR) PROCEDURE TERM;
α RPTR(EXPR) $$1; INTEGER I;
$$1←FACTOR;
WHILE (#TOKEN=OPERATOR_TYPE OR #TOKEN=RES_TYPE) AND TOKEN_CLASS = #TERM DO
α I←TOKEN_INDEX;
GGTOKEN; EXPR:NEXT[$$1]←FACTOR;
$$1←MAKE_CODE(I,2,$$1);
β;
RETURN($$1);
β;
RECURSIVE RPTR(EXPR) PROCEDURE FACTOR;
α RPTR(EXPR)$$1,$$2,$$3; INTEGER I,I2;
LABEL FINISH;
CASE #TOKEN OF
α
[REAL_TYPE]
[INT_TYPE]
α
$$1←MK_EXPR(TOKEN_PTR,TOKEN_INDEX);
GGTOKEN(FALSE);
β;
[ID_TYPE]
BEGIN RPTR(EXPR)$$4;
$$4←PUSHSYMSTACK(TOKEN_PTR,TOKENINDEX);
IF FN_CUR≠NULL_RECORD THEN
α
INTEGER I;
FOR I←1 STEP 1 UNTIL FUNCTION:NARGS[FN_CUR]
DO IF EQU(TOKEN,FUNCTION:ARGNAME[FN_CUR][I])
THEN
α
$$1←MK_EXPR(FUNCTION:PTR[FN_CUR][I],#EX);
DONE;
β;
IF I≤ FUNCTION:NARGS[FN_CUR] THEN
α GGTOKEN(FALSE); GOTO FINISH; β
β;
IF TOKEN_INDEX = #FN
THEN BEGIN INTEGER I3;
RPTR(FUNCTION) QQ; RPTR(SYMBOL)QQ2;
QQ←SYMBOL:OBJECT[QQ2←TOKEN_PTR];
I2 ← FUNCTION:NARGS[QQ] ;
IF SYMBOL:NUSES[QQ2]>0 THEN
BEGIN STRING SS,S,SS2; SS2←SS←NULL;
FOR I3←1 STEP 1 UNTIL SYMBOL:NUSES[QQ2]
DO IF ¬SYMBOL:VALID[EXPR:PTR[SYMBOL:USES[QQ2][I3]]]
THEN
BEGIN
INTEGER I4;
RPTR(SYMBOL) SY;
IF(SY←CHECKTOT(S←SYMBOL:PNAME[EXPR:PTR[SYMBOL:USES[QQ2][I3]]],I4))
=NULL_RECORD
THEN SS←SS&" "&S
ELSE
IF I4≠EXPR:TYPE[SYMBOL:USES[QQ2][I3]]
THEN SS2←SS2&" "&S
ELSE α EXPR:PTR[SYMBOL:USES[QQ2][I3]]←SY;
ADDSYMUSED(QQ2,SY);
β;
END;
IF SS≠NULL THEN ERROR("In function "&SYMBOL:PNAME[QQ2]
&" the following variables are nonexistent:"
& SS);
IF SS2≠NULL THEN ERROR("In function "&SYMBOL:PNAME[QQ2]
&" the following variables are of a different data type than specified"
& SS2);
END;
$$2←$$1←MK_EXPR(QQ, #FN) ;
I←0;
IF I2>0 THEN
α GGTOKEN;I←0;
IF TOKEN≠"(" THEN
ERROR("require left paren here");
DO α
GGTOKEN;$$3←EXP; I←I+1;
EXPR:NEXT[$$2]←$$3;
$$2←$$3;
β UNTIL TOKEN≠"," ;
IF TOKEN≠")" THEN ERROR("need right paren here");
β;
$$1←MAKE_CODE(FUNCTION_X, I, $$1);
GGTOKEN(FALSE);
END
ELSE
α
$$1←MK_EXPR($$4,#SY);
GGTOKEN(FALSE);
β;
END;
[OPERATOR_TYPE]
CASE TOKEN_INDEX OF
α
[LPAREN_X]
α GGTOKEN; $$2←$$1←EXP; I2←1;
IF TOKEN≠")"
THEN WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP;
I2←I2+1;
$$2←(EXPR:NEXT[$$2]←$$3);
β;
IF TOKEN≠")" THEN
ERROR("MISMATCHED PAREN,WILL INSERT")
ELSE GGTOKEN(FALSE);
IF I2≠1 THEN $$1←MAKE_CODE(IMPLICIT_X,I2,$$1);
β;
[MAGNITUDE_X]
α GGTOKEN; $$1←EXP;
IF TOKEN="|"
THEN GGTOKEN(FALSE)
ELSE ERROR("MISMATCHED VERT BAR");
$$1←MAKE_CODE(MAGNITUDE_X,1,$$1);
β;
[UPARROW_X][DOWNARROW_X][DOLLAR_X][ALPHA_X]
α INTEGER I; I←TOKEN_INDEX;
GGTOKEN; $$1←EXP;
$$1←MAKE_CODE(I,1,$$1);
β;
ELSE ERROR("UNEXPECTED TOKEN FOUND"&TOKEN)
β;
[RES_TYPE]
IF EQU(TOKEN,"BPARK")
THEN α $$1←MK_EXPR(F_BPARK,#FR);
GTOKEN(FALSE); β
ELSE IF EQU(TOKEN,"YPARK")
THEN α $$1←MK_EXPR(F_YPARK,#FR);
GTOKEN(FALSE); β
ELSE
IF TOKEN_INDEX=EVAL_X
THEN α RPTR(TREE) $TR; STRING S;RPTR(ANY_CLASS)TEMP;
EXPRESSION_STRING←EXPRESSION_STRING[1 TO ∞-4]&"{ "&TOKEN;
GGTOKEN;
IF TOKEN≠"(" THEN ERROR("REQUIRE LEFT PAREN")
ELSE $TR←GTEXPR;
$$1←MK_EXPR(TEMP←TREE:DATA[$TR],TREE:DTYPE[$TR]);
CASE TREE:DTYPE[$TR] OF
BEGIN "CASE"
[#SC] S← CVGX(SCALAR:VALUE[TEMP]);
[#VT] S← STR_VT(VECTOR:XC[TEMP],
VECTOR:YC[TEMP],(VECTOR:ZC[TEMP]),8);
[#RT] S←STR_RT(ROT:XF[TEMP]);
[#FR] S←"FRAME "&STR_TR(FRAME:XF[TEMP],1,8);
[#TR] S←STR_TR(TRANS:XF[TEMP],1,8)
END "CASE";
GGTOKEN;
IF TOKEN≠")" THEN ERROR("REQUIRE RIGHT PAREN")
ELSE
EXPRESSION_STRING←EXPRESSION_STRING&" = } "&S;
GGTOKEN(FALSE);
β
ELSE
α I←TOKEN_INDEX; IF TOKEN_CLASS≠#FACTOR
THEN ERROR(TOKEN&" is not a valid term in an expression");
GGTOKEN;
IF TOKEN≠"("
THEN ERROR("REQUIRE LEFT PAREN, WILL INSERT")
ELSE GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(EXPR:NEXT[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
$$1←MAKE_CODE(I,I2,$$1);
β;
[UNDECLARED_TYPE]
IF FN_CUR=NULL_RECORD THEN ERROR("UNEXPECTED TOKEN FOUND")
ELSE
α
INTEGER I;
FOR I←1 STEP 1 UNTIL FUNCTION:NARGS[FN_CUR]
DO IF EQU(TOKEN,FUNCTION:ARGNAME[FN_CUR][I])
THEN
α
$$1←MK_EXPR(FUNCTION:PTR[FN_CUR][I],#EX);
DONE;
β;
IF I> FUNCTION:NARGS[FN_CUR] THEN ERROR(TOKEN & " IS UNKNOWN");
GGTOKEN(FALSE);
β;
ELSE ERROR("UNEXPECTED TOKEN FOUND")
β;
FINISH: RETURN($$1);
β;
! function evaluation routines: EVAL, REDUCE;
FORWARD RECURSIVE RPTR(EXPR) PROCEDURE EVAL(INTEGER NCODE; RPTR(EXPR)F);
RECURSIVE RPTR(EXPR) PROCEDURE REDUCE(RPTR(EXPR)F);
CASE EXPR:TYPE[F] OF
α
[#SC][#VT][#RT][#TR]
RETURN(MK_EXPR(EXPR:PTR[F],EXPR:TYPE[F]));
[#FR]
IF JOINEDTOARM(EXPR:PTR[F])=F_BARM AND ARMFALSE
THEN ERROR("CANNOT GET TRUE ARM READING: "&ARMERR[ARMFALSE])
ELSE RETURN(MK_EXPR(EXPR:PTR[F],EXPR:TYPE[F]));
[#EX] RETURN (EXPR:PTR[F]);
[#SY] BEGIN
IF EXPR:TYPE[EXPR:PTR[F]]=#FR THEN
IF JOINEDTOARM(SYMBOL:OBJECT[EXPR:PTR[EXPR:PTR[F]]])
AND ARMFALSE THEN ERROR("CANNOT GET TRUE ARM READING: "&ARMERR[ARMFALSE]);
RETURN(MK_EXPR(SYMBOL:OBJECT[EXPR:PTR[EXPR:PTR[F]]],EXPR:TYPE[EXPR:PTR[F]]));
END;
ELSE RETURN(EVAL(EXPR:TYPE[F],EXPR:PTR[F]))
β;
RECURSIVE RPTR(EXPR)PROCEDURE FNEVAL(RPTR(EXPR)F);
BEGIN "eval func" RPTR(EXPR)$1,$2,$3,$4;
RPTR(FUNCTION,SCALAR,VECTOR,ROT,FRAME,TRANS,EXPR) F1;
INTEGER #ARGS;
F1←EXPR:PTR[F]; #ARGS←FUNCTION:NARGS[F1]; $1←F;
α
RPTR(EXPR)ARRAY PTR[0:#ARGS];INTEGER I; I←0;
WHILE $1←EXPR:NEXT[$1]
DO α
I←I+1; $4←REDUCE($1);
ECOPY(PTR[I]←NEW_RECORD(EXPR),FUNCTION:PTR[F1][I]);
ECOPY(FUNCTION:PTR[F1][I],$4);
β;
IF I≠#ARGS THEN ERROR("EVAL ERROR - ARGS TO FUNCTION WRONG NUMBER");
$1←REDUCE(FUNCTION:EXPR[F1]);
IF #ARGS>0 THEN
FOR I←1 STEP 1 UNTIL #ARGS
DO ECOPY(FUNCTION:PTR[F1][I],PTR[I]);
β ;
RETURN($1);
END "eval func" ;
RECURSIVE RPTR(EXPR) PROCEDURE EVAL(INTEGER NCODE; RPTR(EXPR) F);
BEGIN "EVAL" RPTR(EXPR) $1,$2,$3,$4; INTEGER $$$$,#ARGS;
$$$$←UNCOMPUTE_FUNC(NCODE,1);
IF $$$$=FUNCTION_X
THEN $1←FNEVAL(F)
ELSE BEGIN
$2←$3←REDUCE($1←F);
WHILE $1←EXPR:NEXT[$1]
DO α
$4←REDUCE($1);
EXPR:NEXT[$3]←$4;
$3←$4;
β;
#ARGS←UNCOMPUTE_FUNC(NCODE,2);
$1←EVAL_CODE($$$$,#ARGS,$2);
END;
RETURN($1) ;
END "EVAL";
! GTEXPR, FNEXPR;
! returns the final evaluated form;
INTERNAL RECURSIVE RPTR(TREE)PROCEDURE GTEXPR;
α RPTR(EXPR)$$1,SAVSYMSTACKTOP;
FN_CUR←NULL_RECORD;
SAVSYMSTACKTOP←SYMSTACKTOP;
SYMSTACKTOP←NULL_RECORD;
GGTOKEN;
$$1←EXP;
STOKEN←TRUE;
$GTEXPR←TRUE; READ_BLUE; $GTEXPR←FALSE;
$$1←REDUCE($$1);
SYMSTACKTOP←SAVSYMSTACKTOP;
RETURN(NWTREE(EXPR:PTR[$$1],EXPR:TYPE[$$1]));
β;
! returns the internal form ;
INTERNAL RPTR(TREE)PROCEDURE FNEXPR(RPTR(FUNCTION)F;REFERENCE STRING FBODY;
REFERENCE RPTR(EXPR) SYMUSED);
α RPTR(EXPR)$$1;
EXPRESSION_STRING←NULL;
FN_CUR←F;
GGTOKEN;
SYMSTACKTOP←NULL_RECORD;
$$1←EXP;
STOKEN←TRUE;
FBODY←EXPRESSION_STRING[1 TO ∞ - 1];
SYMUSED←SYMSTACKTOP;
RETURN(NWTREE(EXPR:PTR[$$1],EXPR:TYPE[$$1]));
β;
END;